#lang racket


(require racket/gui/dynamic)

(define frame% (if (gui-available?) (gui-dynamic-require 'frame%) #f))
(define slider% (if (gui-available?) (gui-dynamic-require 'slider%) #f))
(define the-font-list (if (gui-available?) (gui-dynamic-require 'the-font-list) #f))

(when (gui-available?) (dynamic-require 'racket/gui/base 0))


(require "constructors/main.rkt")

(provide sliders)


(define (argument<-slider param slider)
  (let ((s (send slider get-value)))
    (if (or (empty? (cdr param)) (empty? (cddr param)) (empty? (cdddr param)))
        s
        (* s (cadddr param)))))

(define (label<-parameter param)
  (car param))

(define (min-value<-parameter param)
  (if (empty? (cdr param))
      0
      (cadr param)))

(define (max-value<-parameter param)
  (if (or (empty? (cdr param)) (empty? (cddr param)) (empty? (cdddr param)))
      (if (or (empty? (cdr param)) (empty? (cddr param)))
          100
          (caddr param))
      (caddr param)))


(define prepare-draw
  (let ((first? #t))
    (λ ()
      (cond (first?
             (set! first? #f)
             (begin-undo-mark))
            (else
             (end-undo-mark)
             (undo)
             (begin-undo-mark))))))

(define (make-draw-fn fn params sliders-fn)
  (λ ()
    (prepare-draw)
    (evaluate-toplevel (apply fn (map argument<-slider params (sliders-fn))))))

(define (make-sliders-frame label)
  (new frame% [label label]))

(define (make-slider parent label min-value max-value callback)
  (new slider%
       [parent parent]
       [style '(horizontal vertical-label)]
       [font (send the-font-list
                   find-or-create-font 
                   12 'script 'italic 'bold #f 'smoothed)]
       [label label]
       [min-value min-value]
       [max-value max-value]
       [callback callback]))

(define (make-slider-callback fn params)
  (let ((prev #f))
    (λ (slider event)
      (let ((new (send slider get-value)))
        (unless (eqv? new prev)
          (set! prev new)
          ((fn)))))))

(define (make-sliders parent fn params)
  (letrec ((draw-fn (make-draw-fn fn params (λ () sliders)))
           (sliders
            (map
             (λ (param)
               (make-slider parent
                            (label<-parameter param)
                            (min-value<-parameter param)
                            (max-value<-parameter param)
                            (make-slider-callback (λ () draw-fn) params)))
             params)))
    (draw-fn)
    (send parent show #t)))

(define (sliders label fn params)
  (make-sliders (make-sliders-frame label) fn params))